home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / gmain.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  25.0 KB  |  903 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #define GEN
  11.  
  12. #include <stdio.h>
  13. #include <ctype.h>
  14. #include "hdr.h"
  15. #include "vars.h"
  16. #include "gvars.h"
  17. #include "libhdr.h"
  18. #include "segment.h"
  19. #include "ifile.h"
  20. #include "dbxprots.h"
  21. #include "packprots.h"
  22. #include "g0aprots.h"
  23. #include "dclmapprots.h"
  24. #include "arithprots.h"
  25. #include "axqrprots.h"
  26. #include "axqwprots.h"
  27. #include "genprots.h"
  28. #include "segmentprots.h"
  29. #include "expandprots.h"
  30. #include "procprots.h"
  31. #include "libprots.h"
  32. #include "libfprots.h"
  33. #include "librprots.h"
  34. #include "libwprots.h"
  35. #include "readprots.h"
  36. #include "setprots.h"
  37. #include "initprots.h"
  38. #include "glibprots.h"
  39. #include "gutilprots.h"
  40. #include "miscprots.h"
  41. #include "gmiscprots.h"
  42. #include "gmainprots.h"
  43.  
  44. static void fold_upper(char *);
  45. static void preface();
  46. static void exitf(int);
  47. static void init_gen();
  48. static void finit_gen();
  49.  
  50. IFILE    *AISFILE, *AXQFILE, *STUBFILE, *LIBFILE, *TREFILE;
  51. FILE *MALFILE;
  52. int list_unit_0 = 0; /* set by '0' option to list unit 0 structure */
  53. int peep_option = 1; /* on for peep_hole optimization */
  54.  
  55. extern Segment    CODE_SEGMENT, DATA_SEGMENT, DATA_SEGMENT_MAIN;
  56. extern Tuple units_in_compilation;
  57. extern Segment   VARIANT_TABLE, FIELD_TABLE ;
  58.  
  59. #ifdef DEBUG
  60. extern int zpadr_opt; /* not for EXPORT */
  61. #endif
  62.  
  63. char *lib_name;
  64.  
  65. main (int argc, char **argv)
  66. {
  67.     Node     node_new ();
  68.     int        c, i, n, iot_level = 2;
  69.     int        errflg = 0, nobuffer = 0, mflag = 0;
  70.     extern int  optind;
  71.     extern char *optarg;
  72.     char    *fname, *tfname;
  73.     char    *t_name;
  74.     int        r_trace = TRUE, w_trace = TRUE; /* trace modes for -f option */
  75.  
  76.     AISFILE = (IFILE *)0;
  77.     AXQFILE = (IFILE *)0;
  78.     LIBFILE = (IFILE *)0;
  79.     STUBFILE = (IFILE *)0;
  80.     TREFILE = (IFILE *)0;
  81.  
  82.     MAINunit = "";
  83.     interface_files = "";
  84.  
  85.  
  86.     while ((c = getopt (argc, argv, "f:g:l:m:ni:")) != EOF)
  87.         /*    user:
  88.          *    f    file i/o trace, followed by list of options
  89.          *        a    trace ais files
  90.          *        d    do not include descriptors in trace
  91.          *        n    do not include file numbers in trace
  92.          *        r    subsequent traces for reading only
  93.          *        t    trace tre files
  94.          *        w    subsequenc traces for writing only
  95.          *        (traces initially for both r and w, use of r or w
  96.          *        limits further files traces to just that mode)
  97.          *        1    set trace level to 1
  98.          *        2    set trace level to 2
  99.          *    g    debugging, followed by list of options:
  100.          *        0    show structure of unit 0
  101.          *        M    malloc trace (including init_sem)
  102.          *        b    do not buffer standard output
  103.          *        e    flag signalling errors in the parsing phase
  104.          *        g    list generated code
  105.          *        l    show line numbers in generated code
  106.          *        m    malloc trace (after init_sem)
  107.          *        p    compiling predef units
  108.          *        z    call trapini to initialize traps
  109.          *      i   to specify object files and librairies for pragma interface
  110.          *      l    using library
  111.          *        m    main unit name
  112.          *      n    new library
  113.          */
  114.         switch (c) {
  115.         case 'i':
  116.             interface_files = strjoin(interface_files, optarg);
  117.             interface_files = strjoin(interface_files, " ");
  118.             break;
  119.         case 'l': /* using existing library */
  120.             lib_name= emalloc((unsigned) strlen(optarg) + 1);
  121.             strcpy(lib_name, optarg);
  122.             break;
  123.         case 'm': /* specify main unit name */
  124.             MAINunit = malloc((unsigned) strlen(optarg)+1);
  125.             strcpy(MAINunit, optarg);
  126.             fold_upper(MAINunit);
  127.             break;
  128.         case 'n': /* indicates new library */
  129.             new_library = TRUE;
  130.             break;
  131. #ifdef DEBUG
  132.         case 'f':    /* process ifile trace options */
  133.             n = strlen(optarg);
  134.             for (i = 0; i < n; i++) {
  135.                 switch (optarg[i]) {
  136.  
  137.                 case 'o':
  138.                     /* turn off file offset trace */
  139.                     iot_off_info(0);
  140.                     break;
  141.                 case 'a':
  142.                     if (w_trace) iot_ais_w = iot_level;
  143.                     if (r_trace) iot_ais_r = iot_level;
  144.                     break;
  145.                 case 't':
  146.                     if (w_trace) iot_tre_w = iot_level;
  147.                     if (r_trace) iot_tre_r = iot_level;
  148.                     break;
  149.                 case 'l':
  150.                     if (w_trace) iot_lib_w = iot_level;
  151.                     if (r_trace) iot_lib_r = iot_level;
  152.                     break;
  153.                 case 'n': 
  154.                     iot_set_opt_number(0);
  155.                     break;
  156.                 case 'd': 
  157.                     iot_set_opt_desc(0); 
  158.                     break;
  159.                 case 'r': 
  160.                     w_trace= FALSE; 
  161.                     r_trace= TRUE; 
  162.                     break;
  163.                 case 'w': 
  164.                     r_trace = FALSE; 
  165.                     w_trace = TRUE; 
  166.                     break;
  167.                 case '1': 
  168.                     iot_level = 1; 
  169.                     break;
  170.                 case '2': 
  171.                     iot_level = 2; 
  172.                     break;
  173.                 }
  174.             }
  175.             break;
  176. #endif
  177.         case 'g': /* gen debug options */
  178.             n = strlen(optarg);
  179.             for (i = 0; i < n; i++) {
  180.                 switch((int)optarg[i]) {
  181. #ifdef DEBUG
  182.                 case 'a':
  183.                     zpadr_opt = 0; /* do not print addresses in zpadr */
  184.                     break;
  185. #endif
  186.                 case 'g':
  187.                     list_code++;
  188.                     break;
  189.                 case 'l':
  190.                     line_option++;
  191.                     break;
  192.                 case 'p': /* compiling predef units */
  193.                     printf("compiling predef\n");
  194.                     compiling_predef++ ;
  195.                     break;
  196. #ifdef DEBUG
  197.                 case 'b': /* do not buffer output */
  198.                     nobuffer++;
  199.                     break;
  200.                 case 'd': /* force debugging output */
  201.                     debug_flag++;
  202.                     break;
  203.                 case 'e':
  204.                     errors = TRUE;
  205.                     break;
  206.                 case 'o': /* disable optimization (peep) */
  207.                     peep_option = 0;
  208.                     break;
  209.                 case 'm': /* malloc trace */
  210.                     mflag++;
  211.                     break;
  212.                 case '0': /* read trace including unit 0 */
  213.                     list_unit_0++;
  214.                     break;
  215.                 case 'z': 
  216.                     trapini();
  217.                     break;
  218. #endif
  219.                 }
  220.             }
  221.             break;
  222.         case '?':
  223.             errflg++;
  224.         }
  225.     fname = (char *)0;
  226.     if (optind < argc)
  227.         fname = argv[optind];
  228.     if (fname == (char *)0) errflg++;
  229.     if (errflg) {
  230.         fprintf (stderr, "Usage: adagen -aAbglnmMnrstw file\n");
  231.         exitp(RC_ABORT);
  232.     }
  233.     tup_init(); /* initialize set and tuple procedures */
  234. #ifdef DEBUG
  235.     if (mflag) {
  236.         trace_malloc();
  237.         /* can't use strjoin to setup efopen arg as want trace ! */
  238.         /*MALFILE = efopen(strjoin(FILENAME, ".mas"), "w", "t");*/
  239.         tfname = malloc((unsigned) strlen(fname) +4 + 1);
  240.         MALFILE = efopen(strcat(strcpy(tfname, fname), ".mag"), "w", "t");
  241.         free(tfname);
  242.     }
  243. #endif
  244.     FILENAME =  (fname != (char *)0) ? strjoin(fname, "") : fname;
  245.  
  246.     if (compiling_predef) {
  247.         PREDEFNAME = "";
  248.     }
  249.     else
  250.         PREDEFNAME = predef_env();
  251.     if (nobuffer) {
  252.         setbuf (stdout, (char *) 0);    /* do not buffer output (for debug) */
  253.     }
  254.     rat_init(); /* initialize arithmetic and rational package*/
  255.     dstrings_init(2048, 256); /* initialize dstrings package */
  256.     init_sem();
  257.     DATA_SEGMENT_MAIN = main_data_segment();
  258.     aisunits_read = tup_new(0);
  259.     init_symbols = tup_exp(init_symbols, seq_symbol_n);
  260.     for (i = 1; i <= seq_symbol_n; i++)
  261.         init_symbols[i] = seq_symbol[i];
  262.     t_name = libset(lib_name);
  263.  
  264.     num_predef_units = (compiling_predef) ? 0 : init_predef();
  265.  
  266.     /*
  267.      * When the separate compilation facility is being used all references to
  268.      * AIS files will be made via the directory in LIBFILE. AISFILENAME is set
  269.      * to a number.
  270.      */
  271.     if (compiling_predef)
  272.         AISFILENAME = "0";
  273.     else if (new_library)
  274.         AISFILENAME = "1";
  275.     else
  276.         AISFILENAME = lib_aisname(); /* retrieve name from library */
  277.  
  278.     /* open the appropriate files using the suffix .axq for axq files and
  279.      * .trc for tree file. 
  280.      *
  281.      * Open MESSAGEFILE with suffixe ".msg" if a file name specified;
  282.      * otherwise, if a file name not required, and one is not given,
  283.      * used stderr.
  284.      */
  285.     AXQFILE  = ifopen(AISFILENAME, "axq", "w", "a", iot_ais_w, 0);
  286.  
  287.     MSGFILE = (FILENAME != (char *) 0 ) ? efopenl(FILENAME, "msg", "a", "t") :
  288.       stderr;
  289.  
  290.     /* delete any existing st2 file for this AISFILENAME since it is now
  291.      * obsolete
  292.      */
  293.     ifdelete(strjoin(AISFILENAME, ".st2"));
  294.     /* unbuffer output for debugging purposes */
  295.     if (MSGFILE != stderr)
  296.         setbuf(MSGFILE, (char *) 0);
  297.     preface();
  298.  
  299.     /* Code formerly procedure finit() in init.c is now put here directly */
  300.     if (!errors) {
  301.         write_glib();
  302.         cleanup_files();
  303.     }
  304.  
  305.     if (compiling_predef) predef_exceptions(EXCEPTION_SLOTS);
  306.     exitf(RC_SUCCESS);
  307. }
  308.  
  309. static void fold_upper(char *s)                                /*;fold_upper*/
  310. {
  311.     register char c;
  312.  
  313.     while (c = *s) {
  314.         if (islower(c)) *s = toupper(c);
  315.         s++;
  316.     }
  317. }
  318.  
  319. void fold_lower(char *s)                    /*;fold_lower*/
  320. {
  321.     register char c;
  322.  
  323.     while (c = *s) {
  324.         if (isupper(c)) *s = tolower(c);
  325.         s++;
  326.     }
  327. }
  328.  
  329. /* In the SETL version, preface has the global declarations of macros and
  330.  * variables. In the C version, the global variables are defined in gvars.ch
  331.  * (from which gvars.c and gvars.h are derived); macros and structure
  332.  * declarations are in ghdr.h.
  333.  * This file is retained for now to hold parts of code not moved to other
  334.  * files in the C version.
  335.  *
  336.  * pref2 - part 2 of preface: global variables, procedure declarations 
  337.  *
  338.  * Conventions for capitalization.
  339.  * The SETL version uses upper case names for some procedures, macros
  340.  * and global variables. Since case conventions are not enforced by the
  341.  * SETL compiler, there are cases where the same name is written more 
  342.  * than one way, differing only in case.
  343.  
  344.  * In C, we will use upper case for macro names, defined constants and most
  345.  * of the global variables, especially, the variables defined here. Where
  346.  * mixed-case usage is known to exist in the SETL version, such will be
  347.  * indicated by writine (mixed-case) after the variable name.
  348.  */
  349.  
  350. /* macros moved to hdr.c*/
  351.  
  352. static Set units_loaded;
  353.  
  354. static void preface()                                        /*;preface*/
  355. {
  356.     int    indx, last_index, i, rootseq, body_number;
  357.     Node    first_node, unit_node;
  358.     Tuple    aisread_tup, tup;
  359.     int unit_number_now;
  360.     struct unit *pUnit;
  361.     char    *spec_nam;
  362.     aisread_tup = tup_new(0);
  363.     initialize_1();
  364.     /* 1- Load PREDEF */
  365.  
  366.     TASKS_DECLARED = FALSE;
  367.     /* 2- Generate user program */
  368.  
  369.     initialize_2();
  370.  
  371.     if (gen_option) {
  372.         /* read all the units in file, aisunits_read is tuple of unit names of
  373.          * units found in file.
  374.          */
  375.         TREFILE  = ifopen(AISFILENAME, "aic", "r", "a", iot_ais_r, 0);
  376.         last_index = last_comp_index(TREFILE);
  377.         indx = 0;
  378.         units_loaded = set_new(0);
  379.         for (indx = 1; indx <= last_index; indx++) {
  380.             unit_name = read_ais(AISFILENAME, TRUE, (char *) 0, indx, TRUE);
  381.             TREFILE  = ifopen(AISFILENAME, "trc", "r", "t", iot_tre_r, 0);
  382.             load_tre(TREFILE, indx);
  383.             unit_number_now = unit_numbered(unit_name);
  384.             pUnit = pUnits[unit_number_now];
  385.             seq_node_n = pUnit->treInfo.nodeCount;
  386.             seq_node = tup_new(seq_node_n);
  387.  
  388.             /* set seq_symbol to corresponding values of symbols just read in */
  389.             seq_symbol_n = pUnit->aisInfo.numberSymbols;
  390.             tup = (Tuple) pUnit->aisInfo.symbols;
  391.             if ((int) seq_symbol[0] < seq_symbol_n)
  392.                 seq_symbol = tup_exp(seq_symbol, seq_symbol_n);
  393.             for (i = 1; i <= seq_symbol_n; i++)
  394.                 seq_symbol[i] = (char *) tup[i];
  395.  
  396.             rootseq = pUnit->treInfo.rootSeq;
  397.             first_node = (Node) getnodptr(rootseq, unit_number_now);
  398.             unit_node = N_AST2(first_node);
  399.             init_gen();
  400.             if (errors) {
  401.                 /* cannot retrieve message... already printed */
  402.                 user_info("Code generation for ");
  403.                 user_info(strjoin(formatted_name(unit_name), "abandonned"));
  404.             }
  405.             else {
  406.                 save_ada_line = ada_line;
  407.                 mint(unit_node);    /* remove qualify, name, parenthesis */
  408.                 expand(unit_node);
  409.                 if (errors) {
  410. #ifdef DEBUG
  411.                     to_list("Expander stopped");
  412. #endif
  413.                     exitf(RC_ERRORS);
  414.                 }
  415.                 ada_line = save_ada_line;
  416.                 if (N_KIND(unit_node) == as_separate)
  417.                     unit_node = N_AST2(unit_node);
  418.  
  419.                 switch (N_KIND(unit_node)) {
  420.                 case (as_subprogram_tr):
  421.                     if (is_generic(unit_name)) {
  422.                         /* Have the spec  designate this AXQfile */
  423.                         /* spec_nam = ['subprog spec'] + unit_name(2..); */
  424.                         spec_nam = strjoin("ss", unit_name_names(unit_name));
  425.                         /* not sure about use of _MEMORY 
  426.                          * LIB_UNIT(spec_nam)(2) = '_MEMORY';
  427.                          * LIB_UNIT(spec_nam)(3) = '_MEMORY';
  428.                          */
  429.                     }
  430.                     else {
  431.                         unit_subprog(unit_node);
  432.                     }
  433.                     break;
  434.                 case as_subprogram_decl_tr:
  435.                     unit_subprog_spec(unit_node);
  436.                     break;
  437.                 case(as_package_spec):
  438.                     unit_package_spec(unit_node);
  439.                     break;
  440.                 case(as_package_body):
  441.                     if (is_generic(unit_name)) {
  442.                         /* Have the spec  designate this AXQfile */
  443.                         /* spec_nam = ['spec'] + unit_name(2..); */
  444.                         spec_nam = strjoin("sp", unit_name_names(unit_name));
  445.                         /* not sure about use of _MEMORY 
  446.                          * LIB_UNIT(spec_nam)(2) = '_MEMORY';
  447.                          * LIB_UNIT(spec_nam)(3) = '_MEMORY';
  448.                          */
  449.                     }
  450.                     else {
  451.                         unit_package_body(unit_node);
  452.                     }
  453.                     break;
  454.                 case(as_generic_function):
  455.                 case(as_generic_procedure):
  456.                     /* late_instances(UNIT_NAME(2)) := {}; */
  457.                     late_instances = tup_with(late_instances,(char *)unit_name);
  458.                     /* allocate unit_number for body */
  459.                     /* TBSL: this should be done for spec ONLY */
  460.                     body_number =
  461.                       unit_number(strjoin("su", unit_name_names(unit_name)));
  462.                     pUnits[body_number]->libInfo.obsolete = string_ds;
  463.                     break;
  464.                 case(as_generic_package):
  465.                     /* late_instances(UNIT_NAME(2)) := {}; */
  466.                     late_instances = tup_with(late_instances,(char *)unit_name);
  467.                     /* allocate unit_number for body */
  468.                     /* TBSL: this should be done for spec ONLY */
  469.                     body_number =
  470.                       unit_number(strjoin("bo", unit_name_names(unit_name)));
  471.                     pUnits[body_number]->libInfo.obsolete = string_ds;
  472.                     break;
  473.                 case(as_procedure_instance):
  474.                 case(as_function_instance):
  475.                 case(as_package_instance):
  476.                     compiler_error("Late instantiations not implemented");
  477.                     break;
  478.                 default:
  479.                     compiler_error_k("Unexpected unit: ", unit_node);
  480.                 }
  481.                 finit_gen();
  482.                 tup_free(seq_node);
  483.                 if (errors) {
  484. #ifdef DEBUG
  485.                     to_list("Code generation stopped");
  486. #endif
  487.                     exitf(RC_ERRORS);
  488.                 }
  489.                 store_axq(AXQFILE, unit_number_now);
  490.             }
  491.         } /* for */
  492.     }
  493. }
  494.  
  495. static void exitf(int status)                                        /*;exitf*/
  496. {
  497.     /* exit after closing any open files */
  498.     ifoclose(AXQFILE);
  499.     ifoclose(LIBFILE);
  500.     ifoclose(STUBFILE);
  501.     exitp(status);
  502. }
  503.  
  504. void user_error(char *reason)                                    /*;user_error*/
  505. {
  506.     errors++;
  507.     list_hdr(ERR_SEMANTIC);
  508.     fprintf(MSGFILE, " %s\n", reason);
  509. }
  510.  
  511. void user_info(char *line)                                        /*;user_info*/
  512. {
  513.     list_hdr(INFORMATION);
  514.     fprintf(MSGFILE, "%s\n", line);
  515. }
  516.  
  517. static void init_gen()                                            /*;init_gen*/
  518. {
  519.     /*
  520.      *  Initialization of global variables to be performed for each
  521.      *  compilation unit
  522.      */
  523.  
  524.     Tuple    tup;
  525.     struct unit *pUnit;
  526.     int        si, i, unum, u_new;
  527.     int in_names, ii;
  528.     char *tstr;
  529.     char    *unam, *unam_type;
  530.     Set        units_to_load;
  531.     Forset    fs1;
  532.     Fortup    ft1;
  533.     Symbol    unit_unam;
  534.     Tuple    s_info, decscopes, decmaps;
  535.     Unitdecl    ud;
  536.     Stubenv    ev;
  537.  
  538.     if (EMAP != (Tuple)0) tup_free(EMAP);
  539.     EMAP = tup_new(0);
  540. #ifdef TBSN
  541.     /* STATIC_DEPTH POSITION and PATCHES are part of EMAP in C version */
  542.     STATIC_DEPTH         = {
  543.     };
  544.     POSITION         = {
  545.     };
  546.     PATCHES         = {
  547.     };
  548. #endif
  549.     /* PATCH_SET is defined by never used
  550.      *  PATCH_SET         = tup_new(0);
  551.      */
  552.     PARAMETER_SET     = tup_new(0);
  553.     RELAY_SET         = tup_new(0);
  554.     SPECS_DECLARED    =    0;
  555.     SUBPROG_PATCH     = tup_new(0);
  556.     SUBPROG_SPECS     = tup_new(0);
  557.     GENERATED_OBJECTS = tup_new(0);
  558.     DANGLING_RELAY_SETS         = tup_new(0);
  559.     /* Initialize slots correspondint to  SETL OWNED_SLOTS and BORROWED_SLOTS */
  560.     /* Assume that unit_number_now has unit_number corresponding to unit_name */
  561.     /* Set initial unit_slots map to null value */
  562.     /* assume unit_number_now gives curent unit number; the correct
  563.      * assignment of this may best be done elsewhere
  564.      *    ds  6-20-85
  565.      */
  566.     unit_number_now = unit_number(unit_name);
  567.     tup = tup_new(5);
  568.     for (i = 1; i <= 5; i++)
  569.         tup[i] = (char *) tup_new(0);
  570.     unit_slots_put(unit_number_now, tup);
  571.  
  572.     /* remove any slots belonging to this unit from previous compilation */
  573.     remove_slots(CODE_SLOTS, unit_number_now);
  574.     remove_slots(DATA_SLOTS, unit_number_now);
  575.  
  576.     /* remove any pragma interface belonging to this unit from previous
  577.      * compilation
  578.      */
  579.     remove_interface(interfaced_procedures, unit_number_now);
  580.  
  581.     /*  Initialization of global variables */
  582.  
  583. #ifdef TBSN
  584.     NATURE    = INIT_NATURE;
  585.     TYPE_OF   = INIT_TYPE_OF;
  586.     SIGNATURE = INIT_SIGNATURE;
  587.     ALIAS     = INIT_ALIAS;
  588.     TYPE_SIZE = INIT_TYPE_SIZE;
  589.     MISC         = INIT_MISC;
  590.     INIT_PROC = {
  591.     };
  592.     CONSTANT_MAP      = {
  593.     };
  594.     REFERENCE_MAP  = INIT_REFERENCE_MAP;
  595. #endif
  596.     STUBS_IN_UNIT  = FALSE;
  597.     errors = FALSE;
  598.     TASKS_DECLARED = FALSE;
  599.     /*
  600.      * Load necessary (direct and indirect) units BEFORE this one, in order for 
  601.      * body's defns to override spec's. A 'subprog' is loaded only if there 
  602.      * is no corresponding 'subprog spec'. Bodies can be here because of pragma 
  603.      * ELABORATE, and need not be loaded. On the other hand, a body that is an 
  604.      * ancestor of the curr unit, or a generic body, needed for instantiation, 
  605.      * is loaded.
  606.      */
  607.     ud = unit_decl_get(unit_name);
  608.     unit_unam = ud->ud_unam;
  609.     if (NATURE(unit_unam) != na_generic_procedure 
  610.       && NATURE(unit_unam) != na_generic_function
  611.       && NATURE(unit_unam) != na_generic_package) {
  612.         /* do not bring in spec (or anything) for generic unit */
  613.         /* units_to_load = PRE_COMP(unit_name); */
  614.         pUnit = pUnits[unit_number_now];
  615.         units_to_load = set_copy((Set) pUnit->aisInfo.preComp);
  616.         while (set_size(units_to_load) != 0) {
  617. #ifdef TRACE
  618.             if (debug_flag)
  619.                 gen_trace_units("UNITS_TO_LOAD", units_to_load);
  620. #endif
  621.             /* unam from units_to_load; */
  622.             unum = (int) set_from(units_to_load);
  623.             unam = pUnits[unum]->name;
  624.             unam_type = unit_name_type(unam);
  625.             in_names = FALSE;
  626.             tstr = strjoin("sp", unit_name_name(unam));
  627.             for (ii = 1; ii <= unit_numbers; ii++) {
  628.                 if (streq(tstr, pUnits[ii]->name)) {
  629.                     in_names = TRUE;
  630.                     break;
  631.                 }
  632.             }
  633.             if (((streq(unam_type, "sp") || streq(unam_type, "ss"))
  634.               || (streq(unam_type, "su") && !in_names))
  635.               || is_ancestor(unam) || is_generic(unam)) {
  636.                 if (!set_mem((char *) unum, units_loaded)) {
  637.                     errors = errors || !load_unit(unam, TRUE);
  638.                     units_loaded = set_with(units_loaded, (char *) unum);
  639.                 }
  640.                 ud = unit_decl_get(unam) ;
  641.                 private_install(ud->ud_unam) ;
  642.                 /* units_to_load += PRE_COMP(unam) ? {}; --May be om if error */
  643.                 pUnit = pUnits[unum];
  644.                 if ((Set)pUnit->aisInfo.preComp != (Set)0) {
  645.                     /* add any units now yet seen to list of those to be loaded,
  646.                      * but load no unit more than once.
  647.                      */
  648.                     FORSET(u_new = (int), (Set)pUnit->aisInfo.preComp, fs1);
  649.                         if (!set_mem((char *) u_new, units_loaded))
  650.                             units_to_load =
  651.                               set_with(units_to_load, (char *) u_new);
  652.                     ENDFORSET(fs1);
  653.                 }
  654.                 if (is_generic(unam)
  655.                   && (streq(unam_type, "ss")||streq(unam_type, "sp"))) {
  656.                     char *fname, *body_name;
  657.                     if (streq(unam_type, "ss"))
  658.                         body_name = strjoin("su", unit_name_name(unam));
  659.                     else 
  660.                         body_name = strjoin("bo", unit_name_name(unam));
  661.                     fname = lib_unit_get(body_name) ;
  662.                     if (fname != (char *)0) {
  663.                         /* body already seen */
  664.                         load_unit(body_name, TRUE);
  665.                     }
  666.                     else {
  667.                         /* try to read from current file */
  668.                         read_ais(AISFILENAME, TRUE, body_name, 0, TRUE);
  669.                     }
  670.                 }
  671.                 /* Temp kludge until FE removes self references: (generics) */
  672.                 units_to_load = set_less(units_to_load, (char *) unum);
  673.             }
  674.         } /* end while */
  675.         set_free(units_to_load);
  676.     }
  677.  
  678.     if (errors) return;
  679. #ifdef IGNORE
  680.     ud = unit_decl_get(unit_name);
  681.     /* [unit_unam, s_info, decls] = UNIT_DECL(unit_name); */
  682.     unit_unam = ud->ud_unam;
  683. #endif
  684.     s_info = ud->ud_symbols;
  685.     decscopes = ud->ud_decscopes;
  686.     decmaps = ud->ud_decmaps;
  687.     /* TBSL does the info from decscopes and decmaps need to be restored 
  688.      * or is the info restored by symtab_restore since 
  689.      * stored with the symbols.
  690.      * DECLARED  += decls; 
  691.      * SYMBTABQ restore 
  692.      */
  693.     symtab_restore(s_info);
  694.  
  695.     if (is_subunit(unit_name)
  696.       && (NATURE(unit_unam) != na_generic_procedure
  697.       && NATURE(unit_unam) != na_generic_function)) {
  698.         /* retrieve stub environment */
  699.  
  700.         /* [-, -, decl,-,-,-,-,-,-,-,package_info] = STUB_ENV(unit_name);
  701.          * loop forall decls = decl(os) do
  702.          *   loop forall [-, unam, entry] in decls do
  703.          *      SYMBTABF(unam) = entry;
  704.          *   end loop;
  705.          * end loop;
  706.          */
  707.         if (!streq(lib_stub_get(unit_name), AISFILENAME))
  708.             read_stub(lib_stub_get(unit_name), unit_name, "st2");
  709.         si = stub_numbered(unit_name);
  710.         tup = (Tuple) stub_info[si];
  711.         ev = (Stubenv) tup[2];
  712.         update_stub(ev);
  713.         s_info = ev->ev_open_decls;
  714.         symtab_restore(s_info);
  715.     }
  716.     DATA_SEGMENT = segment_new(SEGMENT_KIND_DATA, 0);
  717.     CODE_SEGMENT = segment_new(SEGMENT_KIND_CODE, 0);
  718.  
  719.     /* If the unit was previously compiled remove possible obselete stubs of it
  720.      * from the library.
  721.      */
  722.     FORTUP(unam = (char *), lib_stub, ft1);
  723.         if (stub_parent_get(unam) ==  unit_number_now)
  724.             lib_stub_put(unam, (char *)0);
  725.     ENDFORTUP(ft1);
  726.  
  727. #ifdef MACHINE_CODE
  728.     if (list_code) {
  729.         to_gen(" ");
  730.         to_gen(" ");
  731.         to_gen_unam("============== UNIT : ", formatted_name(unit_name),
  732.             " ==============" );
  733.     }
  734. #endif
  735. }
  736.  
  737. static void finit_gen()                                            /*;finit_gen*/
  738. {
  739.     /*
  740.      * Clean up symbol table, and write it back to file, together with
  741.      * the code slots and the data_segment
  742.      */
  743.  
  744.     int            unum;
  745.     Set            precedes, suppressed_units;
  746.     Forset        fs1;
  747.     Fortup        ft1;
  748.     struct unit *pUnit;
  749.     Tuple        symbols, new_comp_table;
  750.     Symbol        package_name;
  751.     Unitdecl        ud;
  752.  
  753. #ifdef MACHINE_CODE
  754.     if (list_code) {
  755.         to_gen(" ");
  756.         to_gen_unam("============== end of " , formatted_name(unit_name),
  757.             " ==============" );
  758.         to_gen(" ");
  759.         to_gen("--- Global reference map :");
  760.         print_ref_map_global();
  761.     }
  762. #endif
  763.     /* If it is a package, swap private and full declarations 
  764.      *
  765.      * if UNIT_NAME(1) in {'spec', 'body'} then
  766.      *   package_name = UNIT_NAME(2);
  767.      *   temp_symbtab = {};
  768.      *   loop forall [unam, entry] in OVERLOADS(package_name) ? {} do
  769.      *       temp_symbtab(unam) = SYMBTABF(unam);
  770.      *       SYMBTABF(unam) = entry;
  771.      *    end loop;
  772.      *    OVERLOADS(package_name) = temp_symbtab;
  773.      *  end if;
  774.      */
  775.     ud = unit_decl_get(unit_name);
  776.     if (!is_generic(unit_name) && (streq(unit_name_type(unit_name), "sp")
  777.       || streq(unit_name_type(unit_name), "bo"))) {
  778.         package_name =  ud->ud_unam;
  779.         private_exchange(package_name) ;
  780.     }
  781.  
  782.     /* Add Code generator infos to unit symbol table 
  783.      *  [unit_unam, s_info, decls, old_vis, notvis, context, unit_nodes] =
  784.      *     UNIT_DECL(unit_name);
  785.      *
  786.      * loop forall unam in domain s_info do
  787.      * s_info(unam) = SYMBTABFQ(unam);
  788.      * end loop;
  789.      *
  790.      * Add infos for internally generated objects 
  791.      *
  792.      * loop forall unam in GENERATED_OBJECTS do
  793.      *  s_info(unam) = SYMBTABFQ(unam);
  794.      * end loop;
  795.      *
  796.      * UNIT_DECL(unit_name) =
  797.      *    [unit_unam, s_info, decls, old_vis, notvis, context, unit_nodes];
  798.      */
  799.  
  800.     symbols = ud->ud_symbols;
  801.     symbols = tup_add(symbols, GENERATED_OBJECTS);
  802.     ud->ud_symbols = symbols;
  803.  
  804.     if (!is_generic(unit_name)) {
  805.         /* DATA_SEGMENT_MAP(CURRENT_DATA_SEGMENT) = DATA_SEGMENT;*/
  806.         DATA_SEGMENT_MAP = segment_map_put(DATA_SEGMENT_MAP,
  807.           CURRENT_DATA_SEGMENT, DATA_SEGMENT);
  808. #ifdef MACHINE_CODE
  809.         if (list_code) print_data_segment();
  810. #endif
  811.     }
  812.     if (errors) {
  813.         to_gen_unam("Error(s) were detected in ",
  814.           formatted_name(unit_name), " unit not inserted in library");
  815.     }
  816. #ifdef TBSL
  817.     else {
  818.         if (is_generic(unit_name)) {
  819.             /* Free slots allocated by INIT_GEN */
  820.             OWNED_SLOTS(unit_name) = [ {}, {}, {}];
  821.         }
  822. #endif
  823.     /*  Suppress dependant units and collect their slots; update library */
  824.     /*    Report all units which are removed */
  825.     if (!compiling_predef)
  826.         suppressed_units = remove_same_name(unit_name);
  827.     else
  828.         suppressed_units = set_new(0);
  829. #ifdef TBSL
  830.         set_ds = set_cs :
  831.         = set_es :
  832.           = {
  833.           };
  834. #endif
  835.     if (set_size(suppressed_units) != 0) {
  836.         to_list( strjoin(
  837.           "Following unit(s) have been deleted by compilation of ",
  838.           formatted_name(unit_name) ) );
  839.         FORSET(unum = (int), suppressed_units, fs1);
  840.             to_list(formatted_name(pUnits[unum]->name));
  841.  
  842.             /* LIB_UNIT(unam) = OM; */
  843.             lib_unit_put(pUnits[unum]->name, (char *)0);
  844.             precedes_map_put(pUnits[unum]->name, set_new(0));
  845.             /* remove slots belonging to obselete units */
  846.             remove_slots(CODE_SLOTS, unum);
  847.             remove_slots(DATA_SLOTS, unum);
  848.             /* remove pragma interface belonging to obsolete units */
  849.             remove_interface(interfaced_procedures, unum);
  850.         ENDFORSET(fs1);
  851.         to_list(" ");
  852.     }
  853. #ifdef TBSL
  854.     /* Warning: user units may have same name as a predefined one */
  855.     PREDEF_UNITS = [[unam in PREDEF_UNITS(1)
  856.           | unam notin suppressed_units with unit_name],
  857.            PREDEF_UNITS(2) - suppressed_units less unit_name
  858.           ];
  859.  
  860.     DATA_SLOTS     = { [x, y]: 
  861.         [x, y] in DATA_SLOTS
  862.             |   y notin set_ds
  863.             or y in OWNED_SLOTS(unit_name)(1)        };
  864.     CODE_SLOTS     = { [x, y]: 
  865.         [x, y] in CODE_SLOTS
  866.             |   y notin set_cs
  867.             or y in OWNED_SLOTS(unit_name)(2)        };
  868.     EXCEPTION_SLOTS= { [x, y]: 
  869.         [x, y] in EXCEPTION_SLOTS
  870.             |   y notin set_es
  871.             or y in OWNED_SLOTS(unit_name)(3)        };
  872.     /* less unit_name: temporary kludge FE. */
  873. #endif
  874.     /* precedes{unit_name} = PRE_COMP(unit_name) less unit_name; */
  875.     pUnit = pUnits[unit_number_now];
  876.     precedes = set_copy((Set)pUnit->aisInfo.preComp);
  877.     precedes_map_put(unit_name, precedes);
  878.     /* compilation_table = [name: name in compilation_table
  879.      *              | name notin suppressed_units]    with unit_name;
  880.      */
  881.     new_comp_table = tup_new(0);
  882.     FORTUP(unum = (int), compilation_table, ft1);
  883.         if (!set_mem((char *)unum,
  884.            suppressed_units) && unum != unit_number_now)
  885.             new_comp_table = tup_with(new_comp_table, (char *) unum);
  886.     ENDFORTUP(ft1);
  887.     compilation_table = tup_with(new_comp_table, (char *) unit_number_now);
  888.     lib_unit_put(unit_name, AISFILENAME);
  889.     /* if the same compilation unit appears in the same compilation (file)
  890.      * more than once, disable the code for all but the last in the axqfile
  891.      * so that it is not read.
  892.      */
  893.     if (tup_mem((char *)unit_number_now, units_in_compilation))
  894.         overwrite_unit_name(unit_name);
  895.  
  896.     units_in_compilation = 
  897.       tup_with(units_in_compilation, (char *)unit_number_now);
  898.  
  899.     pUnit->libInfo.currCodeSeg = (char *) CURRENT_CODE_SEGMENT;
  900.     if (STUBS_IN_UNIT)
  901.         pUnit->libInfo.localRefMap = (char *) tup_copy(LOCAL_REFERENCE_MAP);
  902. }
  903.